home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / xlisp16.arc / XLDMEM.C < prev    next >
Encoding:
C/C++ Source or Header  |  1985-12-27  |  11.4 KB  |  561 lines
  1. /* xldmem - xlisp dynamic memory management routines */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* useful definitions */
  9. #define ALLOCSIZE (sizeof(struct segment) + (anodes-1) * sizeof(NODE))
  10.  
  11. /* external variables */
  12. extern NODE ***xlstack,***xlstkbase,***xlstktop;
  13. extern NODE *obarray;
  14. extern NODE *xlenv;
  15. extern long total;
  16. extern int anodes,nnodes,nsegs,nfree,gccalls;
  17. extern struct segment *segs;
  18. extern NODE *fnodes;
  19. extern char buf[];
  20.  
  21. /* external procedures */
  22. extern char *malloc();
  23. extern char *calloc();
  24.  
  25. /* forward declarations */
  26. FORWARD NODE *newnode();
  27. FORWARD char *strsave();
  28. FORWARD char *stralloc();
  29.  
  30. /* cons - construct a new cons node */
  31. NODE *cons(x,y)
  32.   NODE *x,*y;
  33. {
  34.     NODE *val;
  35.     val = newnode(LIST);
  36.     rplaca(val,x);
  37.     rplacd(val,y);
  38.     return (val);
  39. }
  40.  
  41. /* consa - (cons x nil) */
  42. NODE *consa(x)
  43.   NODE *x;
  44. {
  45.     NODE *val;
  46.     val = newnode(LIST);
  47.     rplaca(val,x);
  48.     return (val);
  49. }
  50.  
  51. /* consd - (cons nil x) */
  52. NODE *consd(x)
  53.   NODE *x;
  54. {
  55.     NODE *val;
  56.     val = newnode(LIST);
  57.     rplacd(val,x);
  58.     return (val);
  59. }
  60.  
  61. /* cvstring - convert a string to a string node */
  62. NODE *cvstring(str)
  63.   char *str;
  64. {
  65.     NODE ***oldstk,*val;
  66.     oldstk = xlsave(&val,NULL);
  67.     val = newnode(STR);
  68.     val->n_str = strsave(str);
  69.     val->n_strtype = DYNAMIC;
  70.     xlstack = oldstk;
  71.     return (val);
  72. }
  73.  
  74. /* cvcstring - convert a constant string to a string node */
  75. NODE *cvcstring(str)
  76.   char *str;
  77. {
  78.     NODE *val;
  79.     val = newnode(STR);
  80.     val->n_str = str;
  81.     val->n_strtype = STATIC;
  82.     return (val);
  83. }
  84.  
  85. /* cvsymbol - convert a string to a symbol */
  86. NODE *cvsymbol(pname)
  87.   char *pname;
  88. {
  89.     NODE ***oldstk,*val;
  90.     oldstk = xlsave(&val,NULL);
  91.     val = newnode(SYM);
  92.     val->n_symplist = newnode(LIST);
  93.     rplaca(val->n_symplist,cvstring(pname));
  94.     xlstack = oldstk;
  95.     return (val);
  96. }
  97.  
  98. /* cvcsymbol - convert a constant string to a symbol */
  99. NODE *cvcsymbol(pname)
  100.   char *pname;
  101. {
  102.     NODE ***oldstk,*val;
  103.     oldstk = xlsave(&val,NULL);
  104.     val = newnode(SYM);
  105.     val->n_symplist = newnode(LIST);
  106.     rplaca(val->n_symplist,cvcstring(pname));
  107.     xlstack = oldstk;
  108.     return (val);
  109. }
  110.  
  111. /* cvsubr - convert a function to a subr or fsubr */
  112. NODE *cvsubr(fcn,type)
  113.   NODE *(*fcn)(); int type;
  114. {
  115.     NODE *val;
  116.     val = newnode(type);
  117.     val->n_subr = fcn;
  118.     return (val);
  119. }
  120.  
  121. /* cvfile - convert a file pointer to a file */
  122. NODE *cvfile(fp)
  123.   FILE *fp;
  124. {
  125.     NODE *val;
  126.     val = newnode(FPTR);
  127.     setfile(val,fp);
  128.     setsavech(val,0);
  129.     return (val);
  130. }
  131.  
  132. /* cvfixnum - convert an integer to a fixnum node */
  133. NODE *cvfixnum(n)
  134.   FIXNUM n;
  135. {
  136.     NODE *val;
  137.     val = newnode(INT);
  138.     val->n_int = n;
  139.     return (val);
  140. }
  141.  
  142. /* cvflonum - convert a floating point number to a flonum node */
  143. NODE *cvflonum(n)
  144.   FLONUM n;
  145. {
  146.     NODE *val;
  147.     val = newnode(FLOAT);
  148.     val->n_float = n;
  149.     return (val);
  150. }
  151.  
  152. /* newstring - allocate and initialize a new string */
  153. NODE *newstring(size)
  154.   int size;
  155. {
  156.     NODE ***oldstk,*val;
  157.     oldstk = xlsave(&val,NULL);
  158.     val = newnode(STR);
  159.     val->n_str = stralloc(size);
  160.     *getstring(val) = 0;
  161.     val->n_strtype = DYNAMIC;
  162.     xlstack = oldstk;
  163.     return (val);
  164. }
  165.  
  166. /* newobject - allocate and initialize a new object */
  167. NODE *newobject(cls,size)
  168.   NODE *cls; int size;
  169. {
  170.     NODE *val;
  171.     val = newvector(size+1);
  172.     setelement(val,0,cls);
  173.     val->n_type = OBJ;
  174.     return (val);
  175. }
  176.  
  177. /* newvector - allocate and initialize a new vector node */
  178. NODE *newvector(size)
  179.   int size;
  180. {
  181.     NODE ***oldstk,*vect;
  182.     int bsize;
  183.  
  184.     /* establish a new stack frame */
  185.     oldstk = xlsave(&vect,NULL);
  186.  
  187.     /* allocate a vector node and set the size to zero (in case of gc) */
  188.     vect = newnode(VECT);
  189.     vect->n_vsize = 0;
  190.  
  191.     /* allocate memory for the vector */
  192.     bsize = size * sizeof(NODE *);
  193.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL) {
  194.     findmem();
  195.     if ((vect->n_vdata = (NODE **) calloc(1,bsize)) == NULL)
  196.         xlfail("insufficient vector space");
  197.     }
  198.     vect->n_vsize = size;
  199.     total += (long) bsize;
  200.  
  201.     /* restore the previous stack frame */
  202.     xlstack = oldstk;
  203.  
  204.     /* return the new vector */
  205.     return (vect);
  206. }
  207.  
  208. /* newnode - allocate a new node */
  209. LOCAL NODE *newnode(type)
  210.   int type;
  211. {
  212.     NODE *nnode;
  213.  
  214.     /* get a free node */
  215.     if ((nnode = fnodes) == NIL) {
  216.     findmem();
  217.     if ((nnode = fnodes) == NIL)
  218.         xlabort("insufficient node space");
  219.     }
  220.  
  221.     /* unlink the node from the free list */
  222.     fnodes = cdr(nnode);
  223.     nfree -= 1;
  224.  
  225.     /* initialize the new node */
  226.     nnode->n_type = type;
  227.     rplacd(nnode,NIL);
  228.  
  229.     /* return the new node */
  230.     return (nnode);
  231. }
  232.  
  233. /* stralloc - allocate memory for a string adding a byte for the terminator */
  234. LOCAL char *stralloc(size)
  235.   int size;
  236. {
  237.     char *sptr;
  238.  
  239.     /* allocate memory for the string copy */
  240.     if ((sptr = malloc(size+1)) == NULL) {
  241.     findmem();  
  242.     if ((sptr = malloc(size+1)) == NULL)
  243.         xlfail("insufficient string space");
  244.     }
  245.     total += (long) (size+1);
  246.  
  247.     /* return the new string memory */
  248.     return (sptr);
  249. }
  250.  
  251. /* strsave - generate a dynamic copy of a string */
  252. LOCAL char *strsave(str)
  253.   char *str;
  254. {
  255.     char *sptr;
  256.  
  257.     /* create a new string */
  258.     sptr = stralloc(strlen(str));
  259.     strcpy(sptr,str);
  260.  
  261.     /* return the new string */
  262.     return (sptr);
  263. }
  264.  
  265. /* strfree - free a string */
  266. LOCAL strfree(str)
  267.   char *str;
  268. {
  269.     total -= (long) (strlen(str)+1);
  270.     free(str);
  271. }
  272.  
  273. /* findmem - find more memory by collecting then expanding */
  274. findmem()
  275. {
  276.     gc();
  277.     if (nfree < anodes)
  278.     addseg();
  279. }
  280.  
  281. /* gc - garbage collect */
  282. gc()
  283. {
  284.     NODE ***p;
  285.  
  286.     /* mark the obarray and the current environment */
  287.     mark(obarray);
  288.     mark(xlenv);
  289.  
  290.     /* mark the evaluation stack */
  291.     for (p = xlstack; p < xlstktop; )
  292.     mark(**p++);
  293.  
  294.     /* sweep memory collecting all unmarked nodes */
  295.     sweep();
  296.  
  297.     /* count the gc call */
  298.     gccalls++;
  299. }
  300.  
  301. /* mark - mark all accessible nodes */
  302. mark(ptr)
  303.   NODE *ptr;
  304. {
  305.     NODE *this,*prev,*tmp;
  306.  
  307.     /* just return on nil */
  308.     if (ptr == NIL)
  309.     return;
  310.  
  311.     /* initialize */
  312.     prev = NIL;
  313.     this = ptr;
  314.  
  315.     /* mark this list */
  316.     while (TRUE) {
  317.  
  318.     /* descend as far as we can */
  319.     while (TRUE) {
  320.  
  321.         /* check for this node being marked */
  322.         if (this->n_flags & MARK)
  323.         break;
  324.  
  325.         /* mark it and its descendants */
  326.         else {
  327.  
  328.         /* mark the node */
  329.         this->n_flags |= MARK;
  330.  
  331.         /* follow the left sublist if there is one */
  332.         if (livecar(this)) {
  333.             this->n_flags |= LEFT;
  334.             tmp = prev;
  335.             prev = this;
  336.             this = car(prev);
  337.             rplaca(prev,tmp);
  338.         }
  339.  
  340.         /* otherwise, follow the right sublist if there is one */
  341.         else if (livecdr(this)) {
  342.             this->n_flags &= ~LEFT;
  343.             tmp = prev;
  344.             prev = this;
  345.             this = cdr(prev);
  346.             rplacd(prev,tmp);
  347.         }
  348.         else
  349.             break;
  350.         }
  351.     }
  352.  
  353.     /* backup to a point where we can continue descending */
  354.     while (TRUE) {
  355.  
  356.         /* check for termination condition */
  357.         if (prev == NIL)
  358.         return;
  359.  
  360.         /* check for coming from the left side */
  361.         if (prev->n_flags & LEFT)
  362.         if (livecdr(prev)) {
  363.             prev->n_flags &= ~LEFT;
  364.             tmp = car(prev);
  365.             rplaca(prev,this);
  366.             this = cdr(prev);
  367.             rplacd(prev,tmp);
  368.             break;
  369.         }
  370.         else {
  371.             tmp = prev;
  372.             prev = car(tmp);
  373.             rplaca(tmp,this);
  374.             this = tmp;
  375.         }
  376.  
  377.         /* otherwise, came from the right side */
  378.         else {
  379.         tmp = prev;
  380.         prev = cdr(tmp);
  381.         rplacd(tmp,this);
  382.         this = tmp;
  383.         }
  384.     }
  385.     }
  386. }
  387.  
  388. /* vmark - mark a vector */
  389. vmark(n)
  390.   NODE *n;
  391. {
  392.     int i;
  393.     for (i = 0; i < getsize(n); ++i)
  394.     mark(getelement(n,i));
  395. }
  396.  
  397. /* sweep - sweep all unmarked nodes and add them to the free list */
  398. LOCAL sweep()
  399. {
  400.     struct segment *seg;
  401.     NODE *p;
  402.     int n;
  403.  
  404.     /* empty the free list */
  405.     fnodes = NIL;
  406.     nfree = 0;
  407.  
  408.     /* add all unmarked nodes */
  409.     for (seg = segs; seg != NULL; seg = seg->sg_next) {
  410.     p = &seg->sg_nodes[0];
  411.     for (n = seg->sg_size; n--; p++)
  412.         if (!(p->n_flags & MARK)) {
  413.         switch (ntype(p)) {
  414.         case STR:
  415.             if (p->n_strtype == DYNAMIC && p->n_str != NULL) {
  416.                 total -= (long) (strlen(p->n_str)+1);
  417.                 free(p->n_str);
  418.             }
  419.             break;
  420.         case FPTR:
  421.             if (p->n_fp)
  422.                 fclose(p->n_fp);
  423.             break;
  424.         case VECT:
  425.             if (p->n_vsize) {
  426.                 total -= (long) (p->n_vsize * sizeof(NODE **));
  427.                 free(p->n_vdata);
  428.             }
  429.             break;
  430.         }
  431.         p->n_type = FREE;
  432.         p->n_flags = 0;
  433.         rplaca(p,NIL);
  434.         rplacd(p,fnodes);
  435.         fnodes = p;
  436.         nfree++;
  437.         }
  438.         else
  439.         p->n_flags &= ~(MARK | LEFT);
  440.     }
  441. }
  442.  
  443. /* addseg - add a segment to the available memory */
  444. int addseg()
  445. {
  446.     struct segment *newseg;
  447.     NODE *p;
  448.     int n;
  449.  
  450.     /* check for zero allocation */
  451.     if (anodes == 0)
  452.     return (FALSE);
  453.  
  454.     /* allocate a new segment */
  455.     if ((newseg = (struct segment *) calloc(1,ALLOCSIZE)) != NULL) {
  456.  
  457.     /* initialize the new segment */
  458.     newseg->sg_size = anodes;
  459.     newseg->sg_next = segs;
  460.     segs = newseg;
  461.  
  462.     /* add each new node to the free list */
  463.     p = &newseg->sg_nodes[0];
  464.     for (n = anodes; n--; ) {
  465.         rplacd(p,fnodes);
  466.         fnodes = p++;
  467.     }
  468.  
  469.     /* update the statistics */
  470.     total += (long) ALLOCSIZE;
  471.     nnodes += anodes;
  472.     nfree += anodes;
  473.     nsegs++;
  474.  
  475.     /* return successfully */
  476.     return (TRUE);
  477.     }
  478.     else
  479.     return (FALSE);
  480. }
  481.  
  482. /* livecar - do we need to follow the car? */
  483. LOCAL int livecar(n)
  484.   NODE *n;
  485. {
  486.     switch (ntype(n)) {
  487.     case OBJ:
  488.     case VECT:
  489.         vmark(n);
  490.     case SUBR:
  491.     case FSUBR:
  492.     case INT:
  493.     case FLOAT:
  494.     case STR:
  495.     case FPTR:
  496.         return (FALSE);
  497.     case SYM:
  498.     case LIST:
  499.         return (car(n) != NIL);
  500.     default:
  501.         printf("bad node type (%d) found during left scan\n",ntype(n));
  502.         exit();
  503.     }
  504. }
  505.  
  506. /* livecdr - do we need to follow the cdr? */
  507. LOCAL int livecdr(n)
  508.   NODE *n;
  509. {
  510.     switch (ntype(n)) {
  511.     case SUBR:
  512.     case FSUBR:
  513.     case INT:
  514.     case FLOAT:
  515.     case STR:
  516.     case FPTR:
  517.     case OBJ:
  518.     case VECT:
  519.         return (FALSE);
  520.     case SYM:
  521.     case LIST:
  522.         return (cdr(n) != NIL);
  523.     default:
  524.         printf("bad node type (%d) found during right scan\n",ntype(n));
  525.         exit();
  526.     }
  527. }
  528.  
  529. /* stats - print memory statistics */
  530. stats()
  531. {
  532.     sprintf(buf,"Nodes:       %d\n",nnodes);  stdputstr(buf);
  533.     sprintf(buf,"Free nodes:  %d\n",nfree);   stdputstr(buf);
  534.     sprintf(buf,"Segments:    %d\n",nsegs);   stdputstr(buf);
  535.     sprintf(buf,"Allocate:    %d\n",anodes);  stdputstr(buf);
  536.     sprintf(buf,"Total:       %ld\n",total);  stdputstr(buf);
  537.     sprintf(buf,"Collections: %d\n",gccalls); stdputstr(buf);
  538. }
  539.  
  540. /* xlminit - initialize the dynamic memory module */
  541. xlminit()
  542. {
  543.     /* initialize our internal variables */
  544.     anodes = NNODES;
  545.     total = 0L;
  546.     nnodes = nsegs = nfree = gccalls = 0;
  547.     fnodes = NIL;
  548.     segs = NULL;
  549.  
  550.     /* initialize structures that are marked by the collector */
  551.     xlenv = obarray = NIL;
  552.  
  553.     /* allocate the evaluation stack */
  554.     if ((xlstkbase = (NODE ***)malloc(EDEPTH * sizeof(NODE **))) == NULL) {
  555.     printf("insufficient memory");
  556.     exit();
  557.     }
  558.     total += (long)(EDEPTH * sizeof(NODE **));
  559.     xlstack = xlstktop = xlstkbase + EDEPTH;
  560. }
  561.